home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d12 / v10n16.arc / CALC.PAS < prev    next >
Pascal/Delphi Source File  |  1991-08-27  |  8KB  |  291 lines
  1. CALC.PAS
  2.  
  3. {$A+,B-,D-,E-,F+,G-,I+,L-,N-,O+,R-,S-,V-,X-}
  4. UNIT Calc;
  5. (**) INTERFACE (**)
  6.   FUNCTION add(A, B : String) : String;
  7.   FUNCTION sub(A, B : String) : String;
  8.   FUNCTION prod(A, B : String) : String;
  9.   FUNCTION divide(A, B : String; VAR Rm : String):String;
  10.   FUNCTION fact(VAR A : String) : String;
  11.   FUNCTION power(B, E : String) : String;
  12. (**) IMPLEMENTATION (**)
  13.   FUNCTION SubChar(C1, C2 : Char; VAR borrow : Boolean)
  14.              : Char; Assembler;
  15.   {Subtracts one digit char ('0' thru '9') from
  16.    another and returns the result as a digit.  Sets
  17.    borrow to true if appropriate.}
  18.   ASM
  19.     LES DI, Borrow
  20.     MOV Byte Ptr ES:[DI], FALSE
  21.     MOV AL, C1
  22.     SUB AL, C2
  23.     JGE @NoBorrow
  24.     MOV Byte Ptr ES:[DI], TRUE
  25.     ADD AL, 10
  26.     @NoBorrow:
  27.     ADD AL, 30h
  28.   END;
  29.  
  30.   FUNCTION AddChar(C1, C2 : Char; VAR carry : Boolean)
  31.              : Char; Assembler;
  32.   {Adds one digit char ('0' thru '9') to
  33.    another and returns the result as a digit.
  34.    Sets carry to true if appropriate.}
  35.   ASM
  36.     LES DI, Carry
  37.     MOV Byte Ptr ES:[DI], FALSE
  38.     MOV AL, C1
  39.     ADD AL, C2
  40.     SUB AL, 60h {30h for each digit}
  41.     CMP AL, 10
  42.     JL @NoCarry
  43.     SUB AL, 10
  44.     MOV Byte Ptr ES:[DI], TRUE
  45.     @NoCarry:
  46.     ADD AL, 30h
  47.   END;
  48.  
  49.   FUNCTION LeftPad0(S : String; Len : Byte) : String;
  50.   BEGIN
  51.     IF length(S) < Len THEN
  52.       BEGIN
  53.         MOVE(S[1], S[succ(Len - length(S))], length(S));
  54.         FillChar(S[1], Len - length(S), '0');
  55.       END;
  56.     S[0] := Char(Len);
  57.     LeftPad0 := S;
  58.   END;
  59.  
  60.   PROCEDURE TrimLead0(VAR S : String);
  61.   VAR P : Byte;
  62.   BEGIN
  63.     P := 1;
  64.     WHILE (S[P] = '0') AND (P <= length(S)) DO Inc(P);
  65.     CASE P OF
  66.       0 : S[0] := #0; {string was 255 of '0'!}
  67.       1 : ; {not found}
  68.       ELSE
  69.         Move(S[P], S[1], succ(length(S) - P));
  70.         Dec(S[0], pred(P));
  71.     END;
  72.   END;
  73.  
  74.   FUNCTION add(A, B : String) : String;
  75.   VAR T     : String;
  76.       psn   : Word;
  77.       Len   : Byte;
  78.       carry : Boolean;
  79.   BEGIN
  80.     add[0] := #0;
  81.     IF (Length(A) >= 254) THEN Exit;
  82.     IF (Length(B) >= 254) THEN Exit;
  83.     IF A[0] = #0 THEN Exit;
  84.     IF B[0] = #0 THEN Exit;
  85.     carry := False;
  86.     IF Length(A) > Length(B) THEN Len := Succ(Length(A))
  87.     ELSE Len := Succ(Length(B));
  88.     A     := LeftPad0(A, Len);
  89.     B     := LeftPad0(B, Len);
  90.     FillChar(T[1], Len, '0');
  91.     T[0] := Char(Len);
  92.     psn  := Succ(Len);
  93.     {add digits from right to left}
  94.     WHILE psn > 1 DO
  95.       BEGIN
  96.         Dec(psn);
  97.         IF carry THEN
  98.           T[psn] := AddChar(Succ(A[psn]), B[psn], carry)
  99.         ELSE T[psn] := AddChar(A[psn], B[psn], carry);
  100.       END;
  101.     IF carry THEN T[1] := '1';
  102.     TrimLead0(T);
  103.     IF T = '' THEN T := '0';
  104.     add := T;
  105.   END;
  106.  
  107.   FUNCTION Compare(X, Y : String) : ShortInt;
  108.   {Returns -1 if X < Y, 0 if equal, 1 if X > Y}
  109.   BEGIN
  110.     TrimLead0(X);  { cut off any leading zeroes }
  111.     TrimLead0(Y);
  112.     IF Length(X) = Length(Y) THEN
  113.       BEGIN
  114.         IF X = Y THEN Compare := 0
  115.         ELSE IF X > Y THEN Compare := 1
  116.         ELSE Compare := -1;
  117.       END
  118.     ELSE IF Length(X) > Length(Y) THEN Compare := 1
  119.     ELSE Compare := -1;
  120.   END;
  121.  
  122.   FUNCTION sub(A, B : String) : String;
  123.   VAR T             : String;
  124.       psn, Len      : Word;
  125.       borrow, minus : Boolean;
  126.   BEGIN
  127.     sub[0] := #0;
  128.     IF (Length(A) >= 254) THEN Exit;
  129.     IF (Length(B) >= 254) THEN Exit;
  130.     IF A[0] = #0 THEN Exit;
  131.     IF B[0] = #0 THEN Exit;
  132.     borrow := False;
  133.     minus  := False;
  134.     {subtract smaller from larger}
  135.     IF Compare(A, B) = -1 THEN
  136.       BEGIN
  137.         minus := True;
  138.         T := A; A := B; B := T;
  139.       END;
  140.     IF Length(A) > Length(B) THEN Len := Succ(Length(A))
  141.     ELSE Len := Succ(Length(B));
  142.     A    := LeftPad0(A, Len);
  143.     B    := LeftPad0(B, Len);
  144.     FillChar(T[1], Len, '0');
  145.     T[0] := Char(Len);
  146.     psn := Succ(Len);
  147.     {subtract digits from right to left}
  148.     WHILE psn > 1 DO
  149.       BEGIN
  150.         Dec(psn);
  151.         IF borrow THEN
  152.           T[psn] := subChar(Pred(A[psn]), B[psn], borrow)
  153.         ELSE T[psn] := subChar(A[psn], B[psn], borrow);
  154.       END;
  155.     TrimLead0(T);
  156.     IF T = '' THEN T := '0';
  157.     IF minus THEN
  158.       BEGIN
  159.         Move(T[1], T[2], length(T));
  160.         T[1] := '-';
  161.         Inc(T[0]);
  162.       END;
  163.     sub := T;
  164.   END;
  165.  
  166.   FUNCTION prod(A, B : String) : String;
  167.   VAR T1, T2         : String;
  168.       posn, times, N : Word;
  169.   BEGIN
  170.     prod[0] := #0;
  171.     IF (Length(A) + Length(B) > 254) THEN Exit;
  172.     IF A[0] = #0 THEN Exit;
  173.     IF B[0] = #0 THEN Exit;
  174.     {multiply larger by smaller}
  175.     IF Compare(A, B) = -1 THEN
  176.       BEGIN
  177.         T1 := A; A := B; B := T1;
  178.       END;
  179.     T2 := '0';
  180.     {for each digit of multiplier, right to left,
  181.      add together an appropriate number of copies
  182.      of multiplicand, tack the right number of
  183.      zeroes on the end, and add the result to the
  184.      running total in T2}
  185.     FOR posn := Length(B) DOWNTO 1 DO
  186.       BEGIN
  187.         times := Ord(B[posn])-48;
  188.         IF times = 0 THEN T1 := '0'
  189.         ELSE
  190.           BEGIN
  191.             T1 := A;
  192.             FOR N := 2 to times DO
  193.               T1 := add(T1, A);
  194.           END;
  195.         FillChar(T1[succ(length(T1))],
  196.                  length(B)-posn, '0');
  197.         Inc(T1[0], length(B)-posn);
  198.         T2 := add(T2, T1);
  199.       END;
  200.     prod := T2;
  201.   END;
  202.  
  203.   FUNCTION divide(A, B : String; VAR Rm : String):String;
  204.   VAR T1, T2, T3 : String;
  205.   BEGIN
  206.     divide[0]    := #0;
  207.     Rm[0] := #0;
  208.     IF A[0] = #0 THEN Exit;
  209.     IF B[0] = #0 THEN Exit;
  210.     IF Compare(A, B) = 0 THEN
  211.       BEGIN
  212.         divide    := '1';
  213.         Rm := '0';
  214.       END
  215.     ELSE
  216.       BEGIN
  217.         T1 := B; T2 := '1'; T3 := '0';
  218.         {While dividend is > T1, add zeroes to
  219.          T1 and to T2}
  220.         WHILE Compare(A, T1) = 1 DO
  221.           BEGIN
  222.             Inc(T1[0]); T1[length(T1)] := '0';
  223.             Inc(T2[0]); T2[length(T2)] := '0';
  224.           END;
  225.         {get individual digits of quotient by
  226.          repeated subtraction of T1.  T1 is the
  227.          divisor with a steadily decreasing number
  228.          of zeroes after it.}
  229.         WHILE Compare(T1, B) <> 0 DO
  230.           BEGIN
  231.             Dec(T1[0]);
  232.             Dec(T2[0]);
  233.             WHILE Compare(A, T1) <> -1 DO
  234.               BEGIN
  235.                 A := sub(A, T1);
  236.                 IF A[0] = #0 THEN Exit;
  237.                 T3 := add(T3, T2);
  238.                 IF T3[0] = #0 THEN Exit;
  239.               END;
  240.           END;
  241.         divide := T3;
  242.         Rm := A;
  243.       END;
  244.   END;
  245.  
  246.   FUNCTION fact(VAR A : String) : String;
  247.   VAR T1, T2 : String;
  248.   BEGIN
  249.     T1 := '1';
  250.     T2 := '1';
  251.     IF (A <> '1') AND (A <> '0') THEN
  252.       WHILE (T2 <> A) AND (T1[0] <> #0) DO
  253.         BEGIN
  254.           T2 := add(T2, '1');
  255.           T1 := prod(T1, T2);
  256.         END;
  257.     fact := T1;
  258.   END;
  259.  
  260.   FUNCTION power(B, E : String) : String;
  261.   VAR T1, T2, T3, Rem : String;
  262.   BEGIN
  263.     power[0] := #0;
  264.     IF B[0] = #0 THEN Exit;
  265.     IF E[0] = #0 THEN Exit;
  266.     power := '0';
  267.     IF B = '0' THEN Exit;
  268.     power := '1';
  269.     IF E = '0' THEN Exit;
  270.     T1 := B;
  271.     T2 := E;
  272.     T3 := '1';
  273.     {calculate power by halving and squaring}
  274.     WHILE (T2 <> '0') AND (T3[0] <> #0) DO
  275.       BEGIN
  276.         {halve the exponent}
  277.         T2 := divide(T2, '2', rem);
  278.         {if it was odd, multiply T3 by current
  279.          value of T1}
  280.         IF rem = '1' THEN
  281.           T3 := prod(T3, T1);
  282.         {square T1}
  283.         T1 := prod(T1, T1);
  284.       END;
  285.     power := T3;
  286.   END;
  287. END.
  288.  
  289.  
  290.  
  291.